home *** CD-ROM | disk | FTP | other *** search
/ TPUG - Toronto PET Users Group / TPUG Users Group CD / TPUG Users Group CD.iso / AMIGA / (A)TA / (A)TAK.ADF / Klondike / init.bas < prev    next >
BASIC Source File  |  1986-11-06  |  12KB  |  274 lines
  1. 1     ' KLONDIKE SOLITAIR by David Addison  ⌐1986
  2. 2     ' This program is in the Public Domain
  3. 3     '
  4. 4     '
  5. 5     clr:screen 1,3:scnclr:graphic 1
  6. 8     ?:?:?:?:? spc(23);"******  KLONDIKE  SOLITAIR  ******":?:? spc(23);"        by   David Addison"
  7. 10    ?:?:?:? spc(8);"   Click directly on card to put in Foundation, above or below"
  8. 11    ? spc(8);"will pick cards up.  If card can't be played on Foundation the"
  9. 12    ? spc(8);"cards will be picked up."
  10. 13    ?:? spc(8);"   Click on back of card in lower left corner to draw from deck."
  11. 15    ?:?:?:?:? spc(25);"******  PLEASE  STANDBY  ******"
  12. 17    gosub 28000
  13. 18    restore:goto 1110
  14. 20    wave 256,timbre1%():for az=0 to 64 step 20:qq=sound(1,1,1,az,800):qq=sound(2,1,1,az,500):next az:rem **** DRAW CARD ****
  15. 23    c=va:on su goto 36,46,24,28
  16. 24    gshape(x,y),diamond%():pena 6:goto 56
  17. 28    gshape(x,y),heart%():pena 6:goto 56
  18. 36    gshape(x,y),spade%():pena 4:goto 56
  19. 46    gshape(x,y),club%():pena 4
  20. 56    ? at(x+2,y+9);mid$(c$,c,1):? at(x+51,y+45);mid$(c$,c,1):gosub 15000:return
  21. 70    su=int(num/100)
  22. 80    va=num-100*su
  23. 90    return
  24. 100   if hf=1 then gosub 1480:return
  25. 110   if in>51 then 1490
  26. 120   od(in(0))=d(in):in=in+1:x=x(0):y=(in(0)*4)-2:let num=od(in(0)):gosub 70:gosub 20:in(0)=in(0)+1
  27. 125   if in>51 then x=x(0):y=139:for i=y+44 to y step -4:gshape(x,i),blank%():next i
  28. 140   return
  29. 150   '
  30. 188   rem
  31. 189   rem if cu<7 then ? at(13,17);chr$(left(cu));
  32. 190   return
  33. 280   if hf=1 then gosub 1480:return
  34. 290   st=cu
  35. 300   if in(cu)=0 then gosub 1510:return
  36. 310   if cu=0 then let num=od(in(0)-1):goto 330
  37. 320   let num=c(cu,0)
  38. 330   hf=1
  39. 340   if cu=0 then 390
  40. 341   j=y(left(cu))+y(in(cu)-1)+52
  41. 350   for i=y(0)+j to y(0)+y(left(cu))+2 step -4:gshape(x(cu),i),blank%():next i:gosub 150
  42. 390   if cu=0 then for i=(in(0)*4)+56 to (in(0)*4)-4 step -4:gshape(x(0),i),blank%():next i
  43. 392   j=0:if cu=0 then if in(0)-1>0 then let num=od(in(0)-2):gosub 70:x=x(0):y=((in(0)-1)*4)-6:gosub 20:goto 400
  44. 395   if p(cu,0)=0 then for i=y(j)+52 to y(j) step -4:gshape(x(cu),i),blank%():next i:goto 399
  45. 396   wave 256,timbre%():for i=3 to 0 step -1:gshape(x(cu),y(left(cu)-1)),back%():qq=sound(1,1,1,64,(i+1)*1000):qq=sound(2,1,1,64,(i+1)*1000):next i
  46. 399   if cu=0 then gosub 150
  47. 400   gosub 14000:return
  48. 410   if hf=0 then gosub 1520:return
  49. 420   if cu=0 then gosub 590:return
  50. 430   if st=cu then gosub 750:return
  51. 440   if in(cu)=0 then gosub 630:return
  52. 450   let num=c(cu,in(cu)-1)
  53. 460   gosub 70:ts=su:tv=va
  54. 470   if st=0 then let num=od(in(0)-1):goto 490
  55. 480   let num=c(st,0)
  56. 490   gosub 70:if ((ts=1) or (ts=2)) and ((su=1) or (su=2)) then gosub 1530:return
  57. 500   if ((ts=3) or (ts=4)) and ((su=3) or (su=4)) then gosub 1540:return
  58. 510   if tv<>va+1 then gosub 1550:return
  59. 520   if st=0 then gosub 700:return
  60. 530   gosub 25100:for i=0 to in(st)-1:let num=c(st,i):c(cu,in(cu))=num:gosub 70:x=x(cu):y=y(in(cu))+y(left(cu))+2
  61. 535   in(cu)=in(cu)+1:gosub 150:gosub 20
  62. 540   c(st,i)=0:next i:in(st)=0:hf=0
  63. 550   if p(st,0)=0 then return
  64. 560   let num=p(st,0):gosub 70:x=x(st):y=y(0)+y(left(st)-1)+2:gosub 20:c(st,in(st))=num:in(st)=1
  65. 570   for i=0 to 4:p(st,i)=p(st,i+1):next i:p(st,5)=0:left(st)=left(st)-1:if left(st)<0 then left(st)=0
  66. 575   gosub 188
  67. 580   return
  68. 590   if st<>0 then gosub 1560:return
  69. 600   gosub 25100:let num=od(in(0)-1):gosub 70:x=x(cu):y=((in(0)-1)*4)-2:gosub 20:gosub 150
  70. 610   flag=1:hf=0
  71. 620   return
  72. 630   if st=0 then let num=od(in(0)-1):goto 650
  73. 640   let num=c(st,0)
  74. 650   gosub 70
  75. 660   if va<>13 then gosub 1570:return
  76. 670   if st=0 then gosub 700:return
  77. 680   gosub 530
  78. 690   return
  79. 700   x=x(cu):y=y(in(cu))+y(left(cu))+2:c(cu,in(cu))=num:in(cu)=in(cu)+1:gosub 150:gosub 20
  80. 710   in(0)=in(0)-1:od(in(0))=0:hf=0:return
  81. 720   if in>51 then x=x(0):y=139:for i=y+44 to y step -4:gshape(x,i),blank%():next i:return
  82. 730   if in(0)>0 then let num=od(in(0)-1):gosub 70:x=x(0):y=((in(0)-1)*4)-2:gosub 20
  83. 740   return
  84. 750   gosub 25100:for i=0 to in(cu)-1:let num=c(cu,i):gosub 70:x=x(cu):y=y(i)+y(left(cu))+2:gosub 20:next i
  85. 760   hf=0
  86. 770   return
  87. 780   let num=od(in(0)-1):gosub 70:fl=1
  88. 785   if (f(su)<>va-1) and (f(su)=0) then return
  89. 790   if f(su)<>va-1 then tv=f(su):return
  90. 795   for i=(in(0)*4)+64 to (in(0)*4)-4 step -4:gshape(x(0),i),blank%():next i
  91. 800   gosub 980
  92. 810   od(in(cu))=0
  93. 820   if in(cu)=0 then gosub 720:return
  94. 830   gosub 730
  95. 835   gosub 150
  96. 840   return
  97. 850   if p(cu,0)=0 then for i=y(0)+52 to y(0) step -4:gshape(x(cu),i),blank%():next i:goto 875
  98. 855   j=y(left(cu))+52:for i=y(0)+j to y(0)+y(left(cu))+2 step -4:gshape(x(cu),i),blank%():next i
  99. 860   wave 256,timbre%():for i=3 to 0 step -1:gshape(x(cu),y(left(cu)-1)),back%():qq=sound(1,1,1,64,(i+1)*1000):qq=sound(2,1,1,64,(i+1)*1000):next i
  100. 875   c(cu,0)=p(cu,0):gosub 14000
  101. 880   if p(cu,0)=0 then return
  102. 890   let num=c(cu,0):x=x(cu):y=y(0)+y(left(cu)-1)+2:gosub 70:gosub 20
  103. 900   in(cu)=1
  104. 910   for i=0 to 4:p(cu,i)=p(cu,i+1):next i:p(cu,5)=0:left(cu)=left(cu)-1:if left(cu)<0 then left(cu)=0
  105. 915   gosub 188
  106. 920   return
  107. 930   if hf=1 then return
  108. 935   fl=0
  109. 940   if in(cu)=0 then return
  110. 950   if cu=0 then gosub 780:return
  111. 960   let num=c(cu,in(cu)-1):gosub 70
  112. 965   if (f(su)<>va-1) and (f(su)=0) then return
  113. 970   if f(su)<>va-1 then tv=f(su):return
  114. 980   x=x(1)
  115. 990   if su=1 then y=y1
  116. 1000  if su=2 then y=y2
  117. 1010  if su=3 then y=y3
  118. 1020  if su=4 then y=y4
  119. 1030  gosub 20:f(su)=va:fdation=1:money=money+5:gosub 27000
  120. 1040  in(cu)=in(cu)-1:if fl=1 then return
  121. 1050  c(cu,in(cu))=0
  122. 1060  if in(cu)=0 then gosub 850:return
  123. 1070  rem
  124. 1072  for i=y(in(cu))+64+y(left(cu))+2 to y(in(cu))+y(left(cu))+2 step -4:gshape(x(cu),i),blank%()
  125. 1075  next i
  126. 1090  x=x(cu):y=y(in(cu)-1)+y(left(cu))+2:let num=c(cu,in(cu)-1):gosub 70:gosub 20
  127. 1100  return
  128. 1110  dim c(8,12),p(8,5),d(51),od(23),f(4),x(8),y(13),in(8)
  129. 1115  dim back%(400),spade%(400),club%(400),diamond%(400),heart%(400),blank%(100),box%(1000),tempbox%(1000),left(8):what=4
  130. 1116  dim quit%(200),regsave%(100),tx$(13):c$="A23456789TJQK":money=0
  131. 1117  restore 1590:for i=1 to 13:read tx$(i):next i
  132. 1120  gosub 20000:gosub 20100
  133. 1150  for i=0 to 6:for j=0 to 5:c(i,j)=0:p(i,j)=0:next j:for j=6 to 11:c(i,j)=0:next j:next i
  134. 1160  for i=0 to 23:od(i)=0:next i
  135. 1170  for i=0 to 4:f(i)=0:next i
  136. 1180  for i=0 to 8:x(i)=i*69:y(i)=(i*8)-2:next i
  137. 1190  for i=9 to 12:y(i)=(i*8)-2:next i
  138. 1200  y1=-2:y2=45:y3=92:y4=139:y(13)=0:money=money-52
  139. 1220  in=0:for i=1 to 4:for j=1 to 13:d(in)=100*i+j:in=in+1:next j:next i
  140. 1230  randomize -1:for i=51 to 0 step -1:x=int(rnd(1)*i)+1:t=d(x):d(x)=d(i):d(i)=t:next i
  141. 1240  in=0:for i=1 to 6:for j=0 to i-1:p(i+2,j)=d(in):in=in+1:next j:next i
  142. 1250  for i=0 to 6:c(i+2,0)=d(in):in=in+1:left(i+2)=i:next i
  143. 1260  graphic 1
  144. 1290  scnclr:gosub 27000:gosub 30000
  145. 1300  for i=2 to 8:in(i)=1:next i:in(0)=0
  146. 1310  gosub 100
  147. 1320  cu=0:oc=0:x=x(cu):hf=0:fdation=0
  148. 1330  if hf=1 then ask mouse xpos%,ypos%,b%:gosub 25000
  149. 1335  ask mouse xpos%,ypos%,b%:if b%<>4 then 1330
  150. 1336  if xpos%<0 or ypos%<0 or xpos%>617 or ypos%>186 then 1330
  151. 1337  cu=int(xpos%/69):if cu=1 then 1330
  152. 1338  if xpos%>137 and xpos%<192 and ypos%>168 and ypos%<185 then 1420
  153. 1340  if hf=1 then what=5:goto 1400
  154. 1350  if cu=0 and ypos%>139 then what=3:goto 1400
  155. 1352  if cu<>0 then 1360
  156. 1353  if ypos%>(in(cu)*4) and ypos%<(in(cu)*4)+44 then what=2:goto 1400
  157. 1355  if ypos%<(in(cu)*4) or ypos%>(in(cu)*4)+44 then what=4:goto 1400
  158. 1357  goto 1330
  159. 1360  if ypos%>y(in(cu))+y(left(cu))+2 and ypos%<(y(in(cu))+y(left(cu))+2)+44 then what=2:goto 1400
  160. 1370  if ypos%<y(in(cu))+y(left(cu))+2 or ypos%>(y(in(cu))+y(left(cu))+2)+44 then what=4:goto 1400
  161. 1390  goto 1330
  162. 1400  if what=3 then gosub 100:goto 1330
  163. 1402  if what=4 then gosub 280:gosub 27000:goto 1330
  164. 1403  if what=5 then gosub 410:goto 1330
  165. 1404  if what=2 then gosub 930:if fdation=1 then 1620 else what=4:goto 1400
  166. 1410  goto 1330
  167. 1420  sshape(138,168;618,187),tempbox%():gshape(138,168),box%()
  168. 1425  a$="Do you want to end this hand?  (Y or N)":long=len(a$):long=int(long/2):pena 4:? at(377-(long*8),180);a$
  169. 1430  get a$:if a$="" then 1430
  170. 1432  if instr("Yy",a$)>=1 then 1440
  171. 1435  if instr("Nn",a$)>=1 then 1438
  172. 1436  goto 1430
  173. 1438  gshape(138,168),tempbox%():goto 1335
  174. 1440  gshape(138,168),box%():a$="Play another Hand?  (Y or N)":long=len(a$):long=int(long/2):pena 4:? at(377-(long*8),180);a$
  175. 1442  get a$:if a$="" then 1442
  176. 1444  if instr("Yy",a$)>=1 then scnclr:goto 1150
  177. 1446  if instr("Nn",a$)>=1 then system
  178. 1448  goto 1442
  179. 1450  end
  180. 1460  gosub 150
  181. 1470  return
  182. 1480  a$="YOU'VE ALREADY PICKED UP A CARD":GOSUB 16000:GOTO 1610
  183. 1490  a$="THERE ARE NO MORE CARDS IN THE DECK!":GOSUB 16000:GOTO 1610
  184. 1510  a$="THERE ARE NO CARDS HERE TO PICK UP":gosub 16000:goto 1610
  185. 1520  a$="YOU DO NOT HAVE ANY CARDS TO DROP":gosub 16000:goto 1610
  186. 1530  a$="YOU CAN'T PLAY BLACK ON BLACK":gosub 16000:goto 1610
  187. 1540  a$="YOU CAN'T PLAY RED ON RED":gosub 16000:goto 1610
  188. 1550  a$="YOU CAN'T DROP A"+tx$(va)+" ON A"+tx$(tv):gosub 16000:goto 1610
  189. 1560  a$="YOU CAN'T DROP CARDS HERE":gosub 16000:goto 1610
  190. 1570  a$="YOU CAN ONLY DROP A KING HERE":gosub 16000:goto 1610
  191. 1580  a$="START YOUR FOUNDATION WITH AN ACE":gosub 16000:goto 1610
  192. 1590  data "N  ACE"," TWO"," THREE"," FOUR"," FIVE"," SIX"," SEVEN","N EIGHT"," NINE"," TEN"," JACK"," QUEEN"," KING"
  193. 1610  rem
  194. 1615  return
  195. 1620  if f(1)<13 or f(2)<13 or f(3)<13 or f(4)<13 then fdation=0:gosub 27000:goto 1330
  196. 1630  gosub 27000:sshape(138,168;618,187),tempbox%():gshape(138,168),box%()
  197. 1640  a$="***  YOU WIN !!  Care to play again? (Y/N)  ***":long=len(a$):long=int(long/2):pena 4:? at(377-(long*8),180);a$
  198. 1650  get a$:if a$="" then 1650
  199. 1655  if instr("Yy",a$)>0 then 1700
  200. 1660  if instr("Nn",a$)>0 then 1800
  201. 1670  goto 1650
  202. 1700  scnclr:goto 1150
  203. 1800  system
  204. 11000 return
  205. 13000 time=40000
  206. 13005 sleep(time)
  207. 13010 return
  208. 14000 time=90000:goto 13005
  209. 15000 time=70000:goto 13005
  210. 16000 long=len(a$):long=int(long/2)
  211. 16010 sshape(138,168;618,187),tempbox%()
  212. 16020 gshape(138,168),box%()
  213. 16030 pena 4:print at(377-(long*8),180);a$
  214. 16040 sleep(2*10^6)
  215. 16050 gshape(138,168),tempbox%()
  216. 16090 return
  217. 20000 bload "heart_dat",varptr(regsave%(0))
  218. 20010 ct=0:for i%=0 to 31
  219. 20020 rgb i%,regsave%(ct),regsave%(ct+1),regsave%(ct+2)
  220. 20030 ct=ct+3:next i%
  221. 20040 return
  222. 20100 bload "heart",varptr(heart%(0))
  223. 20110 bload "diamond",varptr(diamond%(0))
  224. 20120 bload "club",varptr(club%(0))
  225. 20130 bload "spade",varptr(spade%(0))
  226. 20140 bload "blank",varptr(blank%(0))
  227. 20150 bload "back",varptr(back%(0))
  228. 20160 bload "box",varptr(box%(0))
  229. 20170 bload "quit",varptr(quit%(0))
  230. 20190 return
  231. 25000 rem *** shadow box ***
  232. 25010 drawmode 2
  233. 25020 x2%=xpos%:y2%=ypos%
  234. 25030 box(x2%-30,y2%;x2%+30,y2%+44)
  235. 25040 ask mouse x%,y%,b%
  236. 25050 if b%<>0 then box(x2%-30,y2%;x2%+30,y2%+44):xpos%=x2%:ypos%=y2%:drawmode 0:return
  237. 25060 if x%=x2% and y%=y2% then 25040
  238. 25070 box(x2%-30,y2%;x2%+30,y2%+44)
  239. 25080 x2%=x%:y2%=y%
  240. 25090 box(x2%-30,y2%;x2%+30,y2%+44)
  241. 25095 goto 25040
  242. 25100 return:drawmode 2:box(oldxpos%,oldypos%;oldxpos%+43,oldypos%+59)
  243. 25110 drawmode 0:return
  244. 27000 drawmode 1:penb 0:pena 6:? at(8,136);"$";:? using "#####";money
  245. 27010 drawmode 0:return
  246. 28000 dim timbre%(255),timbre1%(255):k#=2*3.14159265#/256
  247. 28010 for i=0 to 255
  248. 28020 timbre%(i)=31*(sin(i*k#)+sin(2*i*k#)+sin(4*i*k#)+sin(4*i*k#))
  249. 28030 next i
  250. 28040 for i=0 to 255
  251. 28050 timbre1%(i)=-127+(rnd(1)*255)
  252. 28060 next i
  253. 28070 wave 256,timbre1%()
  254. 28080 audio 15,1
  255. 28090 return
  256. 30000 gshape(0,139),back%():peno 5:box(69,0;69+59,0+44),0:box(69,47;69+59,47+44),0:box(69,94;69+59,94+44),0:box(69,141;69+59,141+44),0
  257. 30005 xx%=x(2):yy%=y(0)+2:gosub 32000
  258. 30010 let num=c(2,0):gosub 70:x=x(2):y=y(0):gosub 20
  259. 30020 for i=1 to 6:for j=0 to i-1
  260. 30030 xx%=x(i+2):yy%=y(j)+2:gosub 32000
  261. 30040 x=x(i+2):y=y(j):gshape(x,y),back%()
  262. 30050 next j
  263. 30060 xx%=x(i+2):yy%=y(j)+2:gosub 32000
  264. 30070 let num=c(i+2,0):gosub 70:x=x(i+2):y=y(j):gosub 20
  265. 30080 next i
  266. 30090 gshape(137,168),quit%():return
  267. 32000 peno 4:drawmode 2:ystep=139-yy%:xstep=xx%/10
  268. 32010 ystep=int(ystep/xstep)+2:y=139
  269. 32020 for x=5 to xx% step 20:y=y-ystep
  270. 32030 box(x,y;x+59,y+43),0
  271. 32050 box(x,y;x+59,y+43),0
  272. 32060 next x
  273. 32090 drawmode 0:return
  274.